home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / REFERENC / TPR / SOURCE.EXE / CUSTOMPA.PAS < prev    next >
Pascal/Delphi Source File  |  1992-08-16  |  5KB  |  183 lines
  1. { CUSTOMPA.PAS }
  2. program CustomPattern;
  3.  
  4. { Use this program to help you design a custom fill
  5.   pattern. After the 8 x 8 grid displays, you can use
  6.   the arrow keys to navigate to a specific bit, and set
  7.   it to a 1 by pressing the 1 key, or clearing the bit
  8.   by pressing the 0 key. Press the Esc key to terminate
  9.   data entry and a sample filled circle is displayed on
  10.   the screen. Press Enter to return to pattern editing,
  11.   or press Esc key again to terminate the program.
  12. }
  13.  
  14. uses
  15.   Crt, Graph;
  16.  
  17. const
  18.   { Key equates for the extended key strokes,
  19.     plus Key0 and Key1 for 0 and 1}
  20.   UpArrow       = 72 shl 8;
  21.   LeftArrow     = 75 shl 8;
  22.   RightArrow    = 77 shl 8;
  23.   DownArrow     = 80 shl 8;
  24.   EscapeKey     = 27;
  25.   Key0          = 48;
  26.   Key1          = 49;
  27.  
  28. var
  29.   { Parameters to InitGraph }
  30.   GraphDriver : Integer;
  31.   GraphError  : Integer;
  32.   GraphMode   : Integer;
  33.   { Holds the pattern that we are designing }
  34.   UserPattern : FillPatternType;
  35.   { X, Y position in the matrix }
  36.   X, Y          : Integer;
  37.   { The key that has been pressed }
  38.   KeyCode     : Word;
  39.   F           : File of Byte;
  40.  
  41. procedure BitPlot (X, Y : Integer; BitValue : Boolean );
  42. { Displays each bit in the pattern as a 1 or 0,
  43.   on the display }
  44. begin
  45.   GotoXY ( X*4, Y * 1 );
  46.   If BitValue then
  47.     write('1')
  48.   else
  49.     write('0');
  50. end;
  51.  
  52.  
  53. procedure DisplayPattern ( APattern : FillPatternType );
  54. { Displays the entire pattern on the screen }
  55. var
  56.   X, Y : Integer;
  57. begin
  58.   for X := 1 to 8 do
  59.     for Y := 1 to 8 do
  60.     begin
  61.       BitPlot ( X, Y, (APattern[X] and (256 shr Y)) <> 0);
  62.     end;
  63. end;
  64.  
  65.  
  66. procedure GetChar ( var Key : Word );
  67. { Reads a character from the keyboard, placing
  68.   extended bytes into the high byte of the word
  69.   value returned }
  70. begin
  71.   Key := Word( ReadKey );
  72.   if  Key = 0  then
  73.     { Read extended byte character code }
  74.     Key := Word( ReadKey) shl 8;
  75. end;
  76.  
  77. {$I-}
  78. begin
  79.   Writeln;
  80.   { Set the initial pattern to all 0's (no
  81.     pattern at all) }
  82.   FillChar ( UserPattern, SizeOf ( FillPatternType ), 0 );
  83.  
  84.   Assign( F, 'PATTERN' );
  85.   Reset ( F );
  86.   if IOResult = 0 then
  87.   begin
  88.     Write('Read in existing PATTERN file (Y/N=Cr)? ');
  89.     GetChar ( KeyCode );
  90.     if (KeyCode = Ord('Y')) or
  91.        (KeyCode = Ord('y'))  then
  92.          for X := 1 to 8 do
  93.            Read(F,  UserPattern[X] );
  94.     Close ( F );
  95.   end;
  96.  
  97.  
  98.   { Request autodetection of correct graphics driver }
  99.   GraphDriver := Detect;
  100.  
  101.   { Initialize graphics system; look for driver files
  102.     in specified directory.  You must change the directory
  103.     to the appropriate directory for you system. }
  104.   InitGraph ( GraphDriver, GraphMode, 'F:\BP\BGI' );
  105.  
  106.   GraphError := GraphResult;
  107.   if GraphError <> grOk  then
  108.   begin
  109.     Writeln('Error occurred:', GraphErrorMsg(GraphError) );
  110.     Halt(1);
  111.   end;
  112.  
  113.   { Enter the editing loop }
  114.   repeat
  115.     RestoreCrtMode;
  116.  
  117.     DisplayPattern ( UserPattern );
  118.  
  119.     Gotoxy ( 1, 10 );
  120.     Writeln( 'Use arrow keys to navigate.');
  121.     Writeln(
  122.      'Press 1 to set a bit, press 0 to clear a bit.' );
  123.     Writeln( 'Press Esc key to see the result.' );
  124.     Writeln(
  125.      'Press Esc key TWICE to terminate the program');
  126.     X := 1;
  127.     Y := 1;
  128.     repeat
  129.       GotoXY ( X*4, Y * 1);
  130.       GetChar ( KeyCode );
  131.       case KeyCode of
  132.         Key0:
  133.         begin
  134.           write('0');       { Clear the bit }
  135.       UserPattern[X] :=
  136.         UserPattern[X] and not (256 shr Y);
  137.         end;
  138.         Key1:
  139.         begin
  140.           write('1');       { Set the bit }
  141.       UserPattern[X] :=
  142.         UserPattern[X] or (256 shr Y) ;
  143.         end;
  144.         UpArrow:        if Y > 1 then Dec(Y);
  145.         DownArrow:      if Y < 8 then Inc(Y);
  146.         LeftArrow:      if X > 1 then Dec(X);
  147.         RightArrow:     if X < 8 then Inc(X);
  148.       end;
  149.       Gotoxy ( X*4, Y * 1);
  150.     until KeyCode = EscapeKey;
  151.  
  152.     { After editing the matrix, return to graphics mode
  153.       and display an object containing the pattern. }
  154.     SetGraphMode ( GetGraphMode );
  155.  
  156.     { Display prompt }
  157.     SetTextJustify ( LeftText, BottomText );
  158.     SetTextStyle ( DefaultFont, HorizDir, 1 );
  159.     OutTextXY ( 10, GetMaxY - 10,
  160.       'Press Esc key to stop, any other key to continue editing.');
  161.  
  162.     SetFillPattern ( UserPattern, 3 );
  163.     FillEllipse( GetMaxX div 2, GetMaxY div 2, 75, 75 );
  164.  
  165.     GetChar( KeyCode );
  166.  
  167.   until KeyCode = EscapeKey;
  168.  
  169.   CloseGraph;
  170.   Write('Save pattern to file PATTERN? (Y/N=CR)? ');
  171.   GetChar(KeyCode);
  172.   if (KeyCode = Ord('Y')) or
  173.      (KeyCode = Ord('y'))  then
  174.   begin
  175.     Assign ( F, 'PATTERN' );
  176.     Rewrite( F );
  177.     for X := 1 to 8 do
  178.       Write( F, UserPattern[X] );
  179.     Close ( F );
  180.   end;
  181.  
  182. end.
  183.